home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
t3_1
/
risc_src.lha
/
risc_sources
/
link
/
pmaxsuspend.t
< prev
next >
Wrap
Text File
|
1990-04-10
|
12KB
|
356 lines
(herald pamxsuspend (env tsys (link suspend)))
;;; Look at a Unix a.out description and template.doc
(define (set-up-the-slink)
(modify (+area-frontier (lstate-impure *lstate*))
(lambda (x) (fx+ (fx+ x %%slink-size) %%stack-size)))
(let ((null
(object nil
((heap-stored self) (lstate-impure *lstate*))
((heap-offset self) (fx+ %%stack-size tag/pair))
((write-descriptor self stream)
(write-data stream (fx+ %%stack-size tag/pair)))
((write-store self stream)
(do ((i 0 (fx+ i 4)))
((fx= i %%stack-size))
(write-int stream 0))
(let ((pi (fx+ slink/initial-pure-memory-begin 3)))
(do ((i 0 (fx+ i 4)))
((fx= i pi)
(write-int stream 0)
(write-int stream (+area-frontier (lstate-pure *lstate*)))
(write-data stream %%stack-size)
(write-data stream (+area-frontier (lstate-impure *lstate*)))
(write-int stream (fx-ashl (fx+ (gc-stamp) 1) 2))
(do ((i (fx+ i 20) (fx+ i 4)))
((fx= i %%slink-size))
(write-int stream 0)))
(write-int stream 0)))))))
(set (lstate-null *lstate*) null)
(push (+area-objects (lstate-impure *lstate*)) null)
(text-relocation (fx+ %%stack-size
(fx+ slink/initial-pure-memory-begin 3)))
(text-relocation (fx+ %%stack-size (fx+ slink/initial-pure-memory-end 3)))
(data-relocation (fx+ %%stack-size
(fx+ slink/initial-impure-memory-begin 3)))
(data-relocation (fx+ %%stack-size (fx+ slink/initial-impure-memory-end 3)))
null))
(define (suspend obj out-spec x?)
(set (experimental?) x?)
(really-suspend obj out-spec 'o))
(define-constant RELOC-SIZE 8)
(define-constant MAGIC #x162)
(define-constant TEXT-SYM 1)
(define-constant DATA-SYM 3)
(lset reloc-length 0)
(lset pure-size 0)
(define (vgc-foreign foreign)
(let* ((heap (lstate-impure *lstate*))
(addr (+area-frontier heap))
(name (foreign-name foreign))
(desc (object nil
((heap-stored self) (lstate-impure *lstate*))
((heap-offset self) addr)
((write-descriptor self stream)
(write-data stream (fx+ addr tag/extend)))
((write-store self stream)
(write-int stream header/foreign)
(write-slot name stream)
(write-int stream 0)))))
(set (+area-frontier heap) (fx+ addr 12))
(push (+area-objects heap) desc)
(set-lp-table-entry (lstate-reloc *lstate*) foreign desc)
(generate-slot-relocation name (fx+ addr 4))
(cymbal-thunk (symbol->string name) 0)
(reloc-thunk (fx+ addr 8)
(lstate-symbol-count *lstate*)
#x90)
(modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
desc))
(define (generate-slot-relocation obj slot-address)
(cond ((or (fixnum? obj) (immediate? obj)))
((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
(reloc-thunk slot-address DATA-SYM #x10))
(else
(reloc-thunk slot-address TEXT-SYM #x10))))
(define (text-relocation addr)
(reloc-thunk addr TEXT-SYM #x10))
(define (data-relocation addr)
(reloc-thunk addr DATA-SYM #x10))
(define (reloc-thunk address lw hb)
(push (lstate-data-reloc *lstate*)
(cons address (cons lw hb))))
(lset the-string-table nil)
(define (write-slot obj stream)
(cond ((fixnum? obj)
(write-fixnum stream obj))
((immediate? obj)
(write-immediate stream obj))
((null? obj)
(write-descriptor (lstate-null *lstate*) stream))
((lp-table-entry (lstate-reloc *lstate*) obj)
=> (lambda (desc) (write-descriptor desc stream)))
(else
(write-descriptor (lstate-null *lstate*) stream))))
(define-integrable (write-data stream int)
(write-int stream (fx+ pure-size int)))
(define (write-immediate stream imm)
(let ((int (descriptor->fixnum imm)))
(write-half stream (fx+ (fixnum-ashl int 2) 1))
(write-half stream (fixnum-ashr int 14))))
(define (write-scratch stream obj i)
(let ((offset (fixnum-ashl i 2)))
(write-half stream (mref-16-u obj offset))
(write-half stream (mref-16-u obj (fx+ offset 2)))))
(define (write-int stream int)
(write-half stream int)
(let ((int (fixnum-ashr int 16)))
(write-half stream int)))
(define (write-half stream int)
(vm-write-byte stream int)
(let ((int (fixnum-ashr int 8)))
(vm-write-byte stream int)))
(define (write-fixnum stream fixnum)
(write-half stream (fixnum-ashl fixnum 2))
(write-half stream (fixnum-ashr fixnum 14)))
(define (cymbal-thunk stryng value)
(push (lstate-symbols *lstate*)
(object (lambda (stream)
(write-int stream 0)
(write-int stream (table-entry the-string-table stryng))
(cond ((fx= value 0) ; undefined external (foreign)
(write-int stream 0)
(write-half stream #xf181))
(else
(write-descriptor value stream)
(write-half stream #xf081)))
(write-half stream #xffff))
((cymbal-thunk.stryng self) stryng))))
(define-operation (cymbal-thunk.stryng thunk))
(define (make-global-cymbal proc name)
(cond ((lp-table-entry (lstate-reloc *lstate*) proc)
=> (lambda (desc)
(cymbal-thunk (string-downcase! (symbol->string name))
desc)
(modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
(else
(error "~s not defined" name))))
(define (write-link-file stream)
(make-global-cymbal big_bang 'big_bang)
(make-global-cymbal interrupt_dispatcher 'interrupt_dispatcher)
(set reloc-length (length (lstate-data-reloc *lstate*)))
(modify (lstate-symbols *lstate*) reverse!)
(pad-area (lstate-pure *lstate*))
(pad-area (lstate-impure *lstate*))
(set pure-size (+area-frontier (lstate-pure *lstate*)))
(write-header stream)
(write-aouthdr stream)
(write-text-section-header stream)
(write-data-section-header stream)
(write-area stream (lstate-pure *lstate*))
(write-area stream (lstate-impure *lstate*))
(write-relocation stream)
(receive (i aligned-i) (make-stryng-table)
(write-cymbal-table-header stream aligned-i)
(write-hack-local-symbol stream)
(write-hack-local-string stream)
(write-stryng-table stream (fx- aligned-i i)))
(write-hack-file-descriptor stream)
(write-cymbal-table stream))
(define (write-header stream)
(write-half stream MAGIC) ;magic number
(write-half stream 2) ; # of sections
(write-int stream 0) ; time and date
(write-int stream (cymbal-table-offset))
(write-int stream #x60) ;size of symbol header
(write-half stream #x38) ; size of a.out header
(write-half stream 0)) ;flags
(define (write-aouthdr stream)
(write-half stream #x107) ;magic
(write-half stream #x11f) ;version stamp
(write-int stream (text-size)) ;text size
(write-int stream (data-size)) ;data size
(write-int stream 0) ;bss size
(write-int stream 0) ;entry
(write-int stream 0) ;text base
(write-int stream (text-size)) ;data base
(write-int stream (+ (text-size) (data-size))) ;bss base
(write-int stream 0) ;register mask
(write-int stream 0) ;cp mask [4]
(write-int stream 0)
(write-int stream 0)
(write-int stream 0)
(write-int stream #x8010)) ;gp value ???
(define (write-text-section-header stream)
(write-string stream ".text")
(vm-write-byte stream 0)
(vm-write-byte stream #x20)
(vm-write-byte stream #x20)
(write-int stream 0) ; phys addr
(write-int stream 0) ; virtual addr
(write-int stream (text-size))
(write-int stream (headers-size)) ;offset in file
(write-int stream 0) ; no reloc
(write-int stream 0) ; no gp table
(write-int stream 0)
(write-int stream #x20))
(define (write-data-section-header stream)
(write-string stream ".data")
(vm-write-byte stream 0)
(vm-write-byte stream #x20)
(vm-write-byte stream #x20)
(write-int stream (text-size)) ; phys addr
(write-int stream (text-size)) ; virtual addr
(write-int stream (data-size))
(write-int stream (+ (text-size) (headers-size))) ;offset in file
(write-int stream (+ (headers-size) (text-size) (data-size))) ; reloc
(write-int stream 0) ; no gp table
(write-half stream #xffff) ;reloc overflow
(write-half stream 0) ;no gp table
(write-half stream #x40) ;data flag
(write-half stream #x2000)) ; reloc overflow
(define (headers-size) (fx* 39 4))
(define (text-size) (+area-frontier (lstate-pure *lstate*)))
(define (data-size) (+area-frontier (lstate-impure *lstate*)))
(define (cymbal-table-offset)
(+ (headers-size) (text-size) (data-size)
(* RELOC-SIZE (+ reloc-length 1)))) ;hack number of reloc overflow
(define (write-area stream area)
(walk (lambda (x) (write-store x stream))
(reverse! (+area-objects area))))
(define (write-relocation stream)
(write-int stream (fx+ reloc-length 1)) ;number of relocs
(write-int stream 0) ;R_ABS
(walk (lambda (item)
(destructure (((addr . (lw . hb)) item))
(write-data stream (car item))
(write-half stream lw)
(vm-write-byte stream 0)
(vm-write-byte stream hb)))
(sort-list! (lstate-data-reloc *lstate*)
(lambda (x y)
(fx< (car x) (car y))))))
(define (write-map-entry stream name value) nil)
(define (write-cymbal-table-header stream string-table-size)
(write-half stream #x7009) ;magic
(write-half stream #x11f) ;vstamp
(write-long-zeros stream 7)
(write-int stream 2) ;number of local symbols
(write-int stream (+ (cymbal-table-offset) #x60))
(write-long-zeros stream 4)
(write-int stream 8) ;max index in local strings
(write-int stream (+ (cymbal-table-offset) #x60 24))
(write-int stream string-table-size) ;max string-index
(write-int stream (+ (cymbal-table-offset) #x60 8 24)) ;string table begin
(write-int stream 1) ;fd entries
(write-int stream (+ (cymbal-table-offset) #x60 8 24 string-table-size))
(write-long-zeros stream 2)
(write-int stream (lstate-symbol-count *lstate*)) ;max symbol index
(write-int stream (+ (cymbal-table-offset) #x60 8 24 string-table-size 72)))
(define (write-hack-local-symbol stream)
(write-int stream 1)
(write-int stream 0)
(write-int stream #x204b)
(write-int stream 1)
(write-int stream 0)
(write-int stream #x48))
(define (write-hack-local-string stream)
(vm-write-byte stream 0)
(write-string stream "foo.s")
(vm-write-byte stream 0)
(vm-write-byte stream 0))
(define (write-hack-file-descriptor stream)
(walk (lambda (x) (write-int stream x))
'(0 1 0 7 0 2 0 0 0 0 0 0 0 0 0))
(write-int stream #x223)
(write-int stream 0)
(write-int stream 0))
(define (write-long-zeros stream n)
(do ((i n (fx- i 1)))
((fx= i 0))
(write-int stream 0)))
(define (write-cymbal-table stream)
(walk (lambda (cym) (cym stream)) (lstate-symbols *lstate*)))
(define (make-stryng-table)
(set the-string-table (make-string-table 'stryngs))
(iterate loop ((i 0) (cyms (lstate-symbols *lstate*)))
(cond ((null? cyms) (return i (align i 2)))
(else
(let* ((string (cymbal-thunk.stryng (car cyms)))
(len (string-length string)))
(set (table-entry the-string-table string) i)
(loop (fx+ i (fx+ len 1)) (cdr cyms)))))))
(define (write-stryng-table stream extra)
(walk (lambda (cym)
(write-string stream (cymbal-thunk.stryng cym))
(vm-write-byte stream 0))
(lstate-symbols *lstate*))
(do ((extra extra (fx- extra 1)))
((fx= extra 0))
(vm-write-byte stream 0)))
(define (pad-area area)
(let ((rem (fixnum-remainder (+area-frontier area) 16)))
(cond ((fxn= rem 0)
(modify (+area-frontier area)
(lambda (x) (fx+ x (fx- 16 rem))))
(do ((i (fx- 16 rem) (fx- i 4)))
((fx= i 0))
(push (+area-objects area)
(object nil
((write-store self stream)
(write-int stream 0)))))))))